home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / lang.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  4.9 KB  |  174 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #define GEN
  10.  
  11. #include "hdr.h"
  12. #include "libhdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "attr.h"
  16. #include "setprots.h"
  17. #include "gutilprots.h"
  18. #include "miscprots.h"
  19. #include "gmiscprots.h"
  20. #include "gmainprots.h"
  21. #include "langprots.h"
  22.  
  23. char *c_interface(Symbol sym, int func_code)                /*;c_interface*/
  24. {
  25.     /* generation of a branch of a switch in C containing a call to a
  26.      * subprogram interfaced to C
  27.      */
  28.  
  29.     char    dummy_array[80];
  30.     char     *decl_code = "";
  31.     char     *call_code;
  32.     char     *code;
  33.     char    *proc_name;
  34.     Symbol    formal, formal_type, return_type;
  35.     Tuple    formals;
  36.     Fortup    ft1;
  37.     int     indx;
  38.     int     position = 0;
  39.  
  40.     sprintf(dummy_array, "\tcase(%d):{\n", func_code);
  41.     code = strjoin(dummy_array, "");
  42.     proc_name = strjoin(ORIG_NAME(sym), "");
  43.     fold_lower(proc_name);
  44.     if (NATURE(sym) == na_function) {
  45.         return_type = TYPE_OF(sym);
  46.         if (is_integer_type(return_type))
  47.             sprintf(dummy_array, "\t\textern int %s();\n", proc_name);
  48.         else if (is_float_type(return_type))
  49.             sprintf(dummy_array, "\t\textern float %s();\n", proc_name);
  50.         else
  51.             compiler_error("Interface: TBSL return_type");
  52.         decl_code = strjoin("", dummy_array);
  53.     }
  54.     if (NATURE(sym) == na_function)
  55.         sprintf(dummy_array, "%s(", proc_name);
  56.     else
  57.         sprintf(dummy_array, "\t\t%s(", proc_name);
  58.     call_code = strjoin(dummy_array, "");
  59.     formals = tup_copy(SIGNATURE(sym));
  60.  
  61.     FORTUPI(formal = (Symbol), formals, indx, ft1);
  62.         formal_type = TYPE_OF(formal);
  63.         if (is_integer_type(formal_type) || is_enumeration_type(formal_type))
  64.             sprintf(dummy_array, "\n\t\t\t\t\tget_argument_value(%d)",position);
  65.         else if (is_float_type(formal_type))
  66.             sprintf(dummy_array, "\n\t\t\t\t\tget_float_argument_value(%d)",
  67.               position);
  68.         else if (is_access_type(formal_type))
  69.             sprintf(dummy_array, "\n\t\t\t\t\tget_long_argument_value(%d)",
  70.               position);
  71.         else if (is_array_type(formal_type) || is_record_type(formal_type)) {
  72.             position+=2;
  73.             sprintf(dummy_array, "\n\t\t\t\t\tget_argument_ptr(%d)", position);
  74.         }
  75.         else
  76.             compiler_error("Interface: TBSL non scalar types");
  77.         call_code = strjoin(call_code, dummy_array);
  78.         if (indx != tup_size(formals))
  79.             call_code = strjoin(call_code, ",");
  80.         position += 2;
  81.     ENDFORTUP(ft1);
  82.  
  83.     if (NATURE(sym) == na_function) {
  84.         if (is_integer_type(return_type)) {
  85.             sprintf(dummy_array, "\t\tcur_stack[cur_stackptr - %d] = ",
  86.               position);
  87.         }
  88.         else {
  89.             sprintf(dummy_array,
  90.               "\t\t((float *)cur_stack)[cur_stackptr - %d] = ", position);
  91.         }
  92.         call_code = strjoin(dummy_array, call_code);
  93.     }
  94.     call_code = strjoin(call_code, ");\n\t\tbreak;\n\t}\n");
  95.     code = strjoin(code, decl_code);
  96.     code = strjoin(code, call_code);
  97.     tup_free(formals);
  98.     return code;
  99. }
  100.  
  101. char *fortran_interface(Symbol sym, int func_code)        /*;fortran_interface*/
  102. {
  103.     /* generation of a branch of a switch in C containing a call to a
  104.      * subprogram interfaced to FORTRAN
  105.      */
  106.  
  107.     char    dummy_array[80];
  108.     char     *decl_code = "";
  109.     char     *call_code;
  110.     char     *code;
  111.     char    *proc_name;
  112.     Symbol    formal, formal_type, return_type;
  113.     Tuple    formals;
  114.     Fortup    ft1;
  115.     int     indx;
  116.     int     position = 0;
  117.  
  118.     sprintf(dummy_array, "\tcase(%d):{\n", func_code);
  119.     code = strjoin(dummy_array, "");
  120.     proc_name = strjoin(ORIG_NAME(sym), "");
  121.     fold_lower(proc_name);
  122.     if (NATURE(sym) == na_function) {
  123.         return_type = TYPE_OF(sym);
  124.         if (is_integer_type(return_type)||is_float_type(return_type)) {
  125.             sprintf(dummy_array, "\t\textern int %s();\n", proc_name);
  126.         }
  127.         else {
  128.             compiler_error("Interface: TBSL return_type");
  129.         }
  130.         decl_code = strjoin("", dummy_array);
  131.     }
  132.     if (NATURE(sym) == na_function) {
  133.         sprintf(dummy_array, "%s_(", proc_name);
  134.     }
  135.     else {
  136.         sprintf(dummy_array, "\t\t%s_(", proc_name);
  137.     }
  138.     call_code = strjoin(dummy_array, "");
  139.     formals = tup_copy(SIGNATURE(sym));
  140.  
  141.     FORTUPI(formal = (Symbol), formals, indx, ft1);
  142.         formal_type = TYPE_OF(formal);
  143.         if (is_integer_type(formal_type) || is_float_type(formal_type)
  144.           || is_array_type(formal_type) || is_record_type(formal_type)) {
  145.             if (is_array_type(formal_type) || is_record_type(formal_type)) {
  146.                 position+=2;
  147.             }
  148.             if (indx == tup_size(formals)) {
  149.                 sprintf(dummy_array, "\n\t\t\t\t\tget_argument_ptr(%d)",
  150.                   position);
  151.             }
  152.             else {
  153.                 sprintf(dummy_array, "\n\t\t\t\t\tget_argument_ptr(%d),",
  154.                   position);
  155.             }
  156.         }
  157.         else {
  158.             compiler_error("Interface: unimplemented type for FORTRAN");
  159.         }
  160.         call_code = strjoin(call_code, dummy_array);
  161.         position += 2;
  162.     ENDFORTUP(ft1);
  163.  
  164.     if (NATURE(sym) == na_function) {
  165.         sprintf(dummy_array, "\t\tcur_stack[cur_stackptr - %d] = ", position);
  166.         call_code = strjoin(dummy_array, call_code);
  167.     }
  168.     call_code = strjoin(call_code, ");\n\t\tbreak;\n\t}\n");
  169.     code = strjoin(code, decl_code);
  170.     code = strjoin(code, call_code);
  171.     tup_free(formals);
  172.     return code;
  173. }
  174.